/*
 * Copyright (C) 2012  Paulo Cesar Pereira de Andrade.
 *
 * This is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * This software is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * Authors:
 *	Paulo Cesar Pereira de Andrade
 */

#include "exl.h"

#define void_arith_combine(type)	void_combine(type)
#define real_arith_combine(type)	real_combine(type)
#define number_arith_combine(type)	number_combine(type)
#define vector_arith_combine(type)	vector_combine(type)
#define undef_arith_combine(type)	undef_combine(type)

/*
 * Prototypes
 */
static void
type_ast_stat(east_t *ast);

static etype_t
type_number(east_t *ast);

static etype_t
type_vector_access(east_t *ast);

static etype_t
combine(etype_t ltype, etype_t rtype);

static etype_t
arith_combine(etype_t ltype, etype_t rtype);

static etype_t
canonicalize(etype_t type);

static etype_t
void_combine(etype_t type);

static etype_t
half_combine(etype_t type);

static etype_t
word_combine(etype_t type);

static etype_t
single_combine(etype_t type);

static etype_t
float_combine(etype_t type);

static etype_t
integer_combine(etype_t type);

static etype_t
exact_combine(etype_t type);

static etype_t
inexact_combine(etype_t type);

static etype_t
real_combine(etype_t type);

static etype_t
number_combine(etype_t type);

static etype_t
vector_combine(etype_t type);

static etype_t
undef_combine(etype_t type);

static etype_t
half_arith_combine(etype_t type);

static etype_t
word_arith_combine(etype_t type);

static etype_t
single_arith_combine(etype_t type);

static etype_t
float_arith_combine(etype_t type);

static etype_t
integer_arith_combine(etype_t type);

static etype_t
exact_arith_combine(etype_t type);

static etype_t
inexact_arith_combine(etype_t type);

static ebool_t
shift_check(etype_t type);

static etype_t
type_and(etype_t ltype, etype_t rtype);

static etype_t
type_or(etype_t ltype, etype_t rtype);

static etype_t
type_mul2(etype_t ltype, etype_t rtype);

static etype_t
type_div2(etype_t ltype, etype_t rtype);

static etype_t
type_shl(etype_t ltype, etype_t rtype);

static etype_t
type_shr(etype_t ltype, etype_t rtype);

static etype_t
type_arith(etype_t ltype, etype_t rtype);

static etype_t
type_div(etype_t ltype, etype_t rtype);

static etype_t
type_trunc2(etype_t ltype, etype_t rtype);

static etype_t
type_rem(etype_t ltype, etype_t rtype);

static etype_t
type_com(etype_t type);

static etype_t
type_plus(etype_t type);

static etype_t
unary_arith(etype_t type);

/*
 * Implementation
 */
void
etype_ast(east_t *ast)
{
    east_t		*temp;
    esymbol_t		*symbol;

    switch (ast->token) {
	case tok_set:
	    etype_ast(ast->l.ast);
	    etype_ast(ast->r.ast);
	    /*   Value must not be truncated on set, so, must use r.type */
	    ast->type = ast->r.ast->type;
	    break;
	case tok_andset:	case tok_and:
	    etype_ast(ast->l.ast);
	    etype_ast(ast->r.ast);
	    ast->type = type_and(ast->l.ast->type, ast->r.ast->type);
	    break;
	case tok_orset:		case tok_or:
	case tok_xorset:	case tok_xor:
	    etype_ast(ast->l.ast);
	    etype_ast(ast->r.ast);
	    ast->type = type_or(ast->l.ast->type, ast->r.ast->type);
	    break;
	case tok_mul2set:	case tok_mul2:
	    etype_ast(ast->l.ast);
	    etype_ast(ast->r.ast);
	    ast->type = type_mul2(ast->l.ast->type, ast->r.ast->type);
	    break;
	case tok_div2set:	case tok_div2:
	    etype_ast(ast->l.ast);
	    etype_ast(ast->r.ast);
	    ast->type = type_div2(ast->l.ast->type, ast->r.ast->type);
	    break;
	case tok_shlset:	case tok_shl:
	    etype_ast(ast->l.ast);
	    etype_ast(ast->r.ast);
	    ast->type = type_shl(ast->l.ast->type, ast->r.ast->type);
	    break;
	case tok_shrset:	case tok_shr:
	    etype_ast(ast->l.ast);
	    etype_ast(ast->r.ast);
	    ast->type = type_shr(ast->l.ast->type, ast->r.ast->type);
	    break;
	case tok_addset:	case tok_add:
	case tok_subset:	case tok_sub:
	case tok_mulset:	case tok_mul:
	    etype_ast(ast->l.ast);
	    etype_ast(ast->r.ast);
	    ast->type = type_arith(ast->l.ast->type, ast->r.ast->type);
	    break;
	case tok_divset:	case tok_div:
	    etype_ast(ast->l.ast);
	    etype_ast(ast->r.ast);
	    ast->type = type_div(ast->l.ast->type, ast->r.ast->type);
	    break;
	case tok_trunc2set:	case tok_trunc2:
	    etype_ast(ast->l.ast);
	    etype_ast(ast->r.ast);
	    ast->type = type_trunc2(ast->l.ast->type, ast->r.ast->type);
	    break;
	case tok_remset:	case tok_rem:
	    etype_ast(ast->l.ast);
	    etype_ast(ast->r.ast);
	    ast->type = type_rem(ast->l.ast->type, ast->r.ast->type);
	    break;
	case tok_andand:	case tok_oror:		case tok_ne:
	case tok_lt:		case tok_le:		case tok_eq:
	case tok_ge:		case tok_gt:
	    etype_ast(ast->l.ast);
	    etype_ast(ast->r.ast);
	    ast->type = t_bool;
	    break;
	case tok_not:
	    etype_ast(ast->l.ast);
	    ast->type = t_bool;
	    break;
	case tok_com:
	    etype_ast(ast->l.ast);
	    ast->type = type_com(ast->l.ast->type);
	    break;
	case tok_neg:		case tok_inc:		case tok_dec:
	case tok_postinc:	case tok_postdec:
	    etype_ast(ast->l.ast);
	    ast->type = unary_arith(ast->l.ast->type);
	    break;
	case tok_plus:
	    etype_ast(ast->l.ast);
	    ast->type = type_plus(ast->l.ast->type);
	    break;
	case tok_complex:
	    etype_ast(ast->l.ast);
	    etype_ast(ast->r.ast);
	    ast->type = t_number;
	    break;
	case tok_question:
	    etype_ast(ast->t.ast);
	    etype_ast(ast->l.ast);
	    etype_ast(ast->r.ast);
	    if (ast->l.ast->type != ast->r.ast->type)
		eparse_warn(ast, "ternary operator results different types");
	    ast->type = combine(ast->l.ast->type, ast->r.ast->type);
	    break;
	case tok_if:
	    type_ast_stat(ast->t.ast);
	    type_ast_stat(ast->l.ast);
	    type_ast_stat(ast->r.ast);
	    ast->type = t_void;
	    break;
	case tok_return:
	    if (ast->l.ast) {
		etype_ast(ast->l.ast);
		ast->type = ast->l.ast->type;
	    }
	    else
		ast->type = t_void;
	    break;
	case tok_switch:
	    type_ast_stat(ast->t.ast);
	    type_ast_stat(ast->c.ast);
	    ast->type = t_void;
	    break;
	case tok_for:
	    type_ast_stat(ast->l.ast);
	    type_ast_stat(ast->t.ast);
	    type_ast_stat(ast->r.ast);
	    type_ast_stat(ast->c.ast);
	    ast->type = t_void;
	    break;
	case tok_do:
	    type_ast_stat(ast->c.ast);
	    type_ast_stat(ast->t.ast);
	    ast->type = t_void;
	    break;
	case tok_while:
	    type_ast_stat(ast->t.ast);
	    type_ast_stat(ast->c.ast);
	    ast->type = t_void;
	    break;
	case tok_list:
	    type_ast_stat(ast->l.ast);
	    for (temp = ast->l.ast; temp->next; temp = temp->next)
		;
	    ast->type = temp->type;
	    break;
	case tok_call:
	    etype_ast(ast->l.ast);
	    type_ast_stat(ast->r.ast);
	    break;
	case tok_stat:		case tok_code:		case tok_data:
	    type_ast_stat(ast->l.ast);
	    ast->type = t_void;
	    break;
	case tok_decl:
	    etype_ast(ast->l.ast);
	    type_ast_stat(ast->r.ast);
	    break;
	case tok_dot:
	    etype_ast(ast->l.ast);
	    ast->type = ast->l.ast->type;
	    break;
	case tok_vector:
	    etype_ast(ast->l.ast);
	    type_ast_stat(ast->r.ast);
	    ast->type = type_vector_access(ast);
	    break;
	case tok_symbol:
	    symbol = ast->l.value;
	    /* FIXME   For now parser accepts calls to undefined functions. */
	    if (symbol->tag)
		ast->type = etag_to_type(symbol->tag);
	    else
		ast->type = t_void;
	    break;
	case tok_number:
	    ast->type = type_number(ast);
	    break;
	case tok_string:
	    ast->type = t_string;
	    break;
	case tok_type:		case tok_label:		case tok_goto:
	case tok_break:		case tok_continue:	case tok_case:
	case tok_default:	case tok_class:		case tok_function:
	    ast->type = t_void;
	    break;
	default:
#if DEBUG
	    eparse_warn(ast, "type_ast: not handling %s",
			etoken_to_charp(ast->token));
#endif
	    ast->type = t_void;
	    break;
    }
}

etype_t
etag_to_type(etag_t *tag)
{
    erecord_t		*record;
    evector_t		*vector;

    switch (tag->type) {
	case tag_auto:
	    return (t_undef);
	case tag_basic:		case tag_class:
	    record = (erecord_t *)tag->name;
	    return (record->type);
	case tag_vector:
	    while (tag->base)
		tag = tag->base;
	    return (t_vector | etag_to_type(tag));
	default:
	    /*   FIXME Assuming a function call, not a function pointer. */
	    assert(tag->type == tag_function);
	    vector = tag->name;
	    return (etag_to_type(vector->v.ptr[0]));
    }
}

static void
type_ast_stat(east_t *ast)
{
    for (; ast; ast = ast->next)
	etype_ast(ast);
}

static etype_t
type_vector_access(east_t *ast)
{
    etag_t		*tag;

    for (tag = eeval_ast_tag(ast); tag->base; tag = tag->base)
	;

    return (etag_to_type(tag));    
}

static etype_t
type_number(east_t *ast)
{
    etype_t		type;
    eword_t		word;

    if (ast->l.value == null)
	return (t_null);
    if ((type = etype(ast->l.value)) == t_word) {
	word = *(eword_t *)ast->l.value;
	if (word == 0 || word == 1)
	    return (t_bool);
#if __WORDSIZE == 32
	if ((eint16_t)word == word)
	    return (t_half);
#else
	if ((eint32_t)word == word)
	    return (t_half);
#endif
    }

    return (type);
}

static etype_t
combine(etype_t ltype, etype_t rtype)
{
    ltype = canonicalize(ltype);
    rtype = canonicalize(rtype);
    switch (ltype) {
	case t_void:		return (void_combine(rtype));
	case t_half:		return (half_combine(rtype));
	case t_word:		return (word_combine(rtype));
	case t_single:		return (single_combine(rtype));
	case t_float:		return (float_combine(rtype));
	case t_integer:		return (integer_combine(rtype));
	case t_exact:		return (exact_combine(rtype));
	case t_inexact:		return (inexact_combine(rtype));
	case t_real:		return (real_combine(rtype));
	case t_number:		return (number_combine(rtype));
	case t_vector:		return (vector_combine(rtype));
	default:		return (undef_combine(rtype));
    }
}

static etype_t
arith_combine(etype_t ltype, etype_t rtype)
{
    ltype = canonicalize(ltype);
    rtype = canonicalize(rtype);
    switch (ltype) {
	case t_void:		return (void_arith_combine(rtype));
	case t_half:		return (half_arith_combine(rtype));
	case t_word:		return (word_arith_combine(rtype));
	case t_single:		return (single_arith_combine(rtype));
	case t_float:		return (float_arith_combine(rtype));
	case t_integer:		return (integer_arith_combine(rtype));
	case t_exact:		return (exact_arith_combine(rtype));
	case t_inexact:		return (inexact_arith_combine(rtype));
	case t_real:		return (real_arith_combine(rtype));
	case t_number:		return (number_arith_combine(rtype));
	case t_vector:		return (vector_arith_combine(rtype));
	default:		return (undef_arith_combine(rtype));
    }
}

static etype_t
canonicalize(etype_t type)
{
    switch (type) {
	case t_void:
	    return (t_void);
	case t_null:		case t_bool:		case t_int8:
	case t_uint8:		case t_int16:
#if __WORDSIZE == 32
	    return (t_half);
#endif
	case t_uint16:		case t_int32:
#if __WORDSIZE == 32
	    return (t_word);
#else
	    return (t_half);
#endif
	case t_uint32:		case t_int64:
#if __WORDSIZE == 64
	    return (t_word);
#endif
	case t_uint64:		case t_mpz:		case t_integer:
	    return (t_integer);
	case t_float32:
	    return (t_single);
	case t_float64:
	    return (t_float);
	case t_rat:		case t_mpq:		case t_exact:
	    return (t_exact);
	case t_mpr:		case t_inexact:
	    return (t_inexact);
	case t_real:
	    return (t_real);
	case t_cdd:		case t_cqq:		case t_mpc:
	case t_number:
	    return (t_number);
	default:
	    if (type & t_vector)
		return (t_vector);
	    return (t_undef);
    }
}

static etype_t
void_combine(etype_t type)
{
    if (type == t_void)
	return (t_void);
    return (t_undef);
}

static etype_t
half_combine(etype_t type)
{
    switch (type) {
	case t_single:		case t_float:		case t_inexact:
	    return (t_real);
	case t_half:		case t_word:		case t_integer:
	case t_exact:		case t_real:		case t_number:
	    return (type);
	default:
	    return (t_undef);
    }
}

static etype_t
word_combine(etype_t type)
{
    switch (type) {
	case t_half:
	    return (t_word);
	case t_single:		case t_float:		case t_inexact:
	    return (t_real);
	case t_word:		case t_integer:		case t_exact:
	case t_real:		case t_number:
	    return (type);
	default:
	    return (t_undef);
    }
}

static etype_t
single_combine(etype_t type)
{
    switch (type) {
	case t_half:		case t_word:		case t_integer:
	case t_exact:
	    return (t_real);
	case t_single:		case t_float:		case t_inexact:
	case t_real:		case t_number:
	    return (type);
	default:
	    return (t_undef);
    }
}

static etype_t
float_combine(etype_t type)
{
    switch (type) {
	case t_half:		case t_word:		case t_integer:
	case t_exact:
	    return (t_real);
	case t_single:
	    return (t_float);
	case t_float:		case t_inexact:		case t_real:
	case t_number:
	    return (type);
	default:
	    return (t_undef);
    }
}

static etype_t
integer_combine(etype_t type)
{
    switch (type) {
	case t_half:		case t_word:
	    return (t_integer);
	case t_single:		case t_float:		case t_inexact:
	    return (t_real);
	case t_integer:		case t_exact:		case t_real:
	case t_number:
	    return (type);
	default:
	    return (t_undef);
    }
}

static etype_t
exact_combine(etype_t type)
{
    switch (type) {
	case t_half:		case t_word:
	case t_integer:
	    return (t_exact);
	case t_single:		case t_float:		case t_inexact:
	    return (t_real);
	case t_exact:		case t_real:		case t_number:
	    return (type);
	default:
	    return (t_undef);
    }
}

static etype_t
inexact_combine(etype_t type)
{
    switch (type) {
	case t_half:		case t_word:		case t_single:
	case t_float:		case t_integer:		case t_exact:
	    return (t_real);
	case t_inexact:		case t_real:		case t_number:
	    return (type);
	default:
	    return (t_undef);
    }
}

static etype_t
real_combine(etype_t type)
{
    switch (type) {
	case t_half:		case t_word:		case t_single:
	case t_float:		case t_integer:		case t_exact:
	case t_inexact:
	    return (t_real);
	case t_real:		case t_number:
	    return (type);
	default:
	    return (t_undef);
    }
}

static etype_t
number_combine(etype_t type)
{
    switch (type) {
	case t_half:		case t_word:		case t_single:
	case t_float:		case t_integer:		case t_exact:
	case t_inexact:		case t_real:		case t_number:
	    return (t_number);
	default:
	    return (t_undef);
    }
}

static etype_t
vector_combine(etype_t type)
{
    if (type == t_vector)
	return (t_vector);
    return (t_undef);
}

static etype_t
undef_combine(etype_t type)
{
    return (t_undef);
}

static etype_t
half_arith_combine(etype_t type)
{
    switch (type) {
	case t_single:		case t_float:		case t_inexact:
	case t_half:		case t_word:		case t_integer:
	case t_exact:		case t_real:		case t_number:
	    return (type);
	default:
	    return (t_undef);
    }
}

static etype_t
word_arith_combine(etype_t type)
{
    switch (type) {
	case t_half:
	    return (t_word);
	case t_single:		case t_float:		case t_inexact:
	case t_word:		case t_integer:		case t_exact:
	case t_real:		case t_number:
	    return (type);
	default:
	    return (t_undef);
    }
}

static etype_t
single_arith_combine(etype_t type)
{
    switch (type) {
	case t_half:		case t_word:		case t_integer:
	case t_exact:
	    return (t_single);
	case t_single:		case t_float:		case t_inexact:
	case t_real:		case t_number:
	    return (type);
	default:
	    return (t_undef);
    }
}

static etype_t
float_arith_combine(etype_t type)
{
    switch (type) {
	case t_half:		case t_word:		case t_integer:
	case t_exact:		case t_single:
	    return (t_float);
	case t_float:		case t_inexact:		case t_real:
	case t_number:
	    return (type);
	default:
	    return (t_undef);
    }
}

static etype_t
integer_arith_combine(etype_t type)
{
    switch (type) {
	case t_half:		case t_word:
	    return (t_integer);
	case t_single:		case t_float:		case t_inexact:
	case t_integer:		case t_exact:		case t_real:
	case t_number:
	    return (type);
	default:
	    return (t_undef);
    }
}

static etype_t
exact_arith_combine(etype_t type)
{
    switch (type) {
	case t_half:		case t_word:		case t_integer:
	    return (t_exact);
	case t_single:		case t_float:		case t_inexact:
	case t_exact:		case t_real:		case t_number:
	    return (type);
	default:
	    return (t_undef);
    }
}

static etype_t
inexact_arith_combine(etype_t type)
{
    switch (type) {
	case t_half:		case t_word:		case t_single:
	case t_float:		case t_integer:		case t_exact:
	    return (t_inexact);
	case t_inexact:		case t_real:		case t_number:
	    return (type);
	default:
	    return (t_undef);
    }
}

static ebool_t
shift_check(etype_t type)
{
    switch (canonicalize(type)) {
	case t_half:		case t_word:
	    /*   Ok for shift. */
	case t_integer:
	    /*   Valid if result of type combine.. */
	case t_single:		case t_float:		case t_inexact:
	    /*   May be valid coerced to an integer. */
	    break;
	default:
	    return (false);
    }
    return (true);
}

static etype_t
type_and(etype_t ltype, etype_t rtype)
{
    ltype = canonicalize(ltype);
    rtype = canonicalize(rtype);
    switch (ltype) {
	case t_half:
	    return (t_half);
	case t_word:
	    switch (rtype) {
		case t_half:
		    return (t_half);
		default:
		    return (t_word);
	    }
	    break;
	default:
	    switch (rtype) {
		case t_half:		case t_word:	case t_integer:
		    return (rtype);
		default:
		    /*   Integer or exception. */
		    return (t_integer);
	    }
	    break;
    }
}

static etype_t
type_or(etype_t ltype, etype_t rtype)
{
    etype_t		type;

    switch (type = combine(ltype, rtype)) {
	case t_half:		case t_word:		case t_integer:
	    return (type);
	default:
	    /*   Integer or exception. */
	    return (t_integer);
    }
}

static etype_t
type_mul2(etype_t ltype, etype_t rtype)
{
    etype_t		type;

    if (!shift_check(rtype))
	return (t_undef);
    switch (type = canonicalize(ltype)) {
	case t_half:		case t_word:		case t_integer:
	    return (t_integer);
	case t_single:		case t_float:		case t_exact:
	case t_inexact:		case t_real:		case t_number:
	    return (type);
	default:
	    return (t_undef);
    }
}

static etype_t
type_div2(etype_t ltype, etype_t rtype)
{
    etype_t		type;

    if (!shift_check(rtype))
	return (t_undef);
    switch (type = canonicalize(ltype)) {
	case t_half:		case t_word:		case t_integer:
	    return (t_exact);
	case t_single:		case t_float:		case t_exact:
	case t_inexact:		case t_real:		case t_number:
	    return (type);
	default:
	    return (t_undef);
    }
}

static etype_t
type_shl(etype_t ltype, etype_t rtype)
{
    /*   Integer or exception. */
    return (t_integer);
}

static etype_t
type_shr(etype_t ltype, etype_t rtype)
{
    etype_t		type;

    switch (type = canonicalize(ltype)) {
	case t_half:		case t_word:
	    return (type);
	default:
	    /*   Integer or exception. */
	    return (t_integer);
    }
}

static etype_t
type_arith(etype_t ltype, etype_t rtype)
{
    etype_t		type;

    switch (type = arith_combine(ltype, rtype)) {
	case t_half:
	    return (t_word);
	case t_word:		case t_integer:
	    return (t_integer);
	case t_single:		case t_float:		case t_exact:
	case t_inexact:		case t_real:		case t_number:
	    return (type);
	default:
	    return (t_undef);
    }
}

static etype_t
type_div(etype_t ltype, etype_t rtype)
{
    etype_t		type;

    switch (type = arith_combine(ltype, rtype)) {
	case t_half:		case t_word:		case t_integer:
	case t_exact:
	    /*   t_exact or exception. */
	    return (t_exact);
	case t_single:		case t_float:		case t_inexact:
	case t_real:		case t_number:
	    return (type);
	default:
	    return (t_undef);
    }
}

static etype_t
type_trunc2(etype_t ltype, etype_t rtype)
{
    etype_t		type;

    switch (type = combine(ltype, rtype)) {
	case t_half:		case t_word:
	    return (type);
	default:
	    /*   Integer or exception. */
	    return (t_integer);
    }
}

static etype_t
type_rem(etype_t ltype, etype_t rtype)
{
    etype_t		type;

    switch (type = arith_combine(ltype, rtype)) {
	case t_half:		case t_word:		case t_integer:
	case t_exact:		case t_single:		case t_float:
	case t_inexact:		case t_real:		case t_number:
	    return (type);
	default:
	    /*   Real or exception. */
	    return (t_real);
    }
}

static etype_t
unary_arith(etype_t type)
{
    switch (type = canonicalize(type)) {
	case t_half:
	    return (t_word);
	case t_word:		case t_integer:
	    return (t_integer);
	case t_single:		case t_float:		case t_exact:
	case t_inexact:		case t_real:		case t_number:
	    return (type);
	default:		return (t_undef);
    }
}

static etype_t
type_com(etype_t type)
{
    switch (type = canonicalize(type)) {
	case t_half:		case t_word:		case t_integer:
	    return (type);
	default:
	    /*   Integer or exception. */
	    return (t_integer);
    }
}

static etype_t
type_plus(etype_t type)
{
    switch (type = canonicalize(type)) {
	case t_half:		case t_word:		case t_single:
	case t_float:		case t_integer:		case t_exact:
	case t_inexact:		case t_real:		case t_number:
	    return (type);
	default:
	    return (t_undef);
    }
}
